Visual Basic Toolbox

home *** CD-ROM | disk | FTP | other *** search

/ Visual Basic Toolbox / Visual Basic Toolbox (P.I.E.)(1996).ISO / database / randomfa / aboutdlg.frm (.txt) next >

Wrap

Visual Basic Form | 1995-12-29 | 19.7 KB | 577 lines

VERSION 2.00 Begin Form frmAbout BackColor = &H00C0C0C0& BorderStyle = 3 'Fixed Double Caption = "About Current Program" ClientHeight = 5205 ClientLeft = 2310 ClientTop = 2010 ClientWidth = 6135 FontBold = -1 'True FontItalic = 0 'False FontName = "System" FontSize = 9.75 FontStrikethru = 0 'False FontUnderline = 0 'False Height = 5610 Icon = 0 Left = 2250 LinkMode = 1 'Source LinkTopic = "Form2" MaxButton = 0 'False MinButton = 0 'False ScaleHeight = 5205 ScaleWidth = 6135 Top = 1665 Width = 6255 Begin PictureBox picSquare BackColor = &H00FFFFFF& FontBold = -1 'True FontItalic = 0 'False FontName = "Times New Roman" FontSize = 24 FontStrikethru = 0 'False FontUnderline = 0 'False ForeColor = &H00FF0000& Height = 2865 Left = 240 ScaleHeight = 2835 ScaleWidth = 5640 TabIndex = 5 Top = 2250 Width = 5670 End Begin Timer tmrControl Interval = 1 Left = 360 Top = 1590 End Begin CommandButton cmdOK Caption = "OK" Height = 645 Left = 4560 TabIndex = 2 Top = 1530 Width = 1335 End Begin Label lblGratus Alignment = 2 'Center BackColor = &H00C0C0C0& Caption = "Supplied with the compliments of:" FontBold = -1 'True FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 13.5 FontStrikethru = 0 'False FontUnderline = 0 'False ForeColor = &H000000FF& Height = 390 Left = 720 TabIndex = 7 Top = 30 Width = 4725 End Begin Image imgUKFlag Height = 480 Left = 5580 Picture = ABOUTDLG.FRX:0000 Top = 360 Width = 480 End Begin Line Line1 BorderWidth = 2 X1 = 510 X2 = 5400 Y1 = 1470 Y2 = 1470 End Begin Label lblMsg2 Alignment = 2 'Center BackColor = &H00C0C0C0& Caption = "Fax 0181 364 5296 - Email 100037.37@compuserve.com" ForeColor = &H000000FF& Height = 240 Left = 510 TabIndex = 6 Top = 1230 Width = 4950 End Begin Image imgScrolls Height = 480 Left = 90 Picture = ABOUTDLG.FRX:0302 Top = 390 Width = 480 End Begin Line linLine1 BorderWidth = 2 X1 = 735 X2 = 5265 Y1 = 1140 Y2 = 1140 End Begin Label lblDDC BackColor = &H00C0C0C0& Caption = "DataCraft Development Company" FontBold = -1 'True FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 13.5 FontStrikethru = 0 'False FontUnderline = 0 'False ForeColor = &H00FF0000& Height = 390 Left = 735 TabIndex = 1 Top = 390 Width = 4725 End Begin Label lblMsg1 BackColor = &H00C0C0C0& Caption = "Windows System Development Consultants" FontBold = -1 'True FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 9.75 FontStrikethru = 0 'False FontUnderline = 0 'False ForeColor = &H00FF00FF& Height = 240 Left = 795 TabIndex = 3 Top = 840 Width = 4485 End Begin Label Lbl_Info BackColor = &H00C0C0C0& ForeColor = &H000000FF& Height = 600 Left = 1005 TabIndex = 4 Top = 1560 Width = 1875 End Begin Label Lbl_InfoValues BackColor = &H00C0C0C0& ForeColor = &H000000FF& Height = 600 Left = 2910 TabIndex = 0 Top = 1560 Width = 1410 End Option Explicit DefInt A-Z Const APP_TITLE = "Random Access Files" Const MF_BYPOSITION = &H400 Declare Function GetSystemMenu Lib "User" (ByVal hWnd, ByVal bRevert) Declare Function RemoveMenu Lib "User" (ByVal hMenu, ByVal nPosition, ByVal wFlags) Declare Function GetWinFlags Lib "Kernel" () As Long Declare Function GetFreeSpace Lib "Kernel" (ByVal wFlags) As Long Const WF_STANDARD = &H10 Const WF_ENHANCED = &H20 Const WF_80x87 = &H400 Dim findProcess As Integer Dim fintWidth As Integer Dim fintHeight As Integer Dim fintPrintX As Integer Dim fintPrintY As Integer Sub cmdOK_Click () findProcess = False DoEvents End Sub Sub cmdRunScreenSaver () On Error GoTo DazzleRunError Dim intResult As Integer intResult = Shell(App.Path & "\dazzle.exe -b -w") DazzleRunExit: Exit Sub DazzleRunError: MsgBox "Error while running dazzle.exe:" & Chr$(13) & Error$, 48, "Error Running dazzle.exe" Resume DazzleRunExit: End Sub Sub DrawAllLines () Dim sngStartX As Single Dim sngStartY As Single Dim sngEndX As Single Dim sngEndY As Single Dim intLoop As Integer Dim sngStartLoop As Single Dim sngEndLoop As Single Dim intStep As Single Dim intCount As Integer For intCount = 1 To 2 For intLoop = 1 To 4 Select Case intLoop Case 1 'BL to TR GoSub SetupBox sngStartX = 0 sngEndX = fintWidth sngStartY = fintHeight sngEndY = 0 sngStartLoop = sngStartX sngEndLoop = sngEndX intStep = 4 GoSub XLeg sngStartX = 0 sngEndX = fintWidth sngStartY = fintHeight sngEndY = 0 sngStartLoop = 0 sngEndLoop = fintHeight intStep = 4 GoSub YLeg Case 2 'TL to BR GoSub SetupBox sngStartX = 0 sngEndX = fintWidth sngStartY = 0 sngEndY = fintHeight sngStartLoop = sngStartY sngEndLoop = sngEndY intStep = 4 GoSub YLeg sngStartX = 0 sngEndX = fintWidth sngStartY = 0 sngEndY = fintHeight sngStartLoop = sngEndX sngEndLoop = sngStartX intStep = -4 GoSub XLeg Case 3 'TR to BL GoSub SetupBox sngStartX = fintWidth sngEndX = 0 sngStartY = 0 sngEndY = fintHeight sngStartLoop = sngStartX sngEndLoop = sngEndX intStep = -4 GoSub XLeg sngStartX = fintWidth sngEndX = 0 sngStartY = 0 sngEndY = fintHeight sngStartLoop = sngEndY sngEndLoop = sngStartY intStep = -4 GoSub YLeg Case 4 'BR to TL GoSub SetupBox sngStartX = fintWidth sngEndX = 0 sngStartY = fintHeight sngEndY = 0 sngStartLoop = sngStartY sngEndLoop = sngEndY intStep = -4 GoSub YLeg sngStartX = fintWidth sngEndX = 0 sngStartY = fintHeight sngEndY = 0 sngStartLoop = 0 sngEndLoop = fintWidth intStep = 4 GoSub XLeg End Select Next intLoop Next intCount Exit Sub SetupBox: If findProcess = True Then picSquare.Cls PrintMessage APP_TITLE, RGB(0, 0, 255) End If Return XLeg: If findProcess = True Then For sngStartLoop = sngStartLoop To sngEndLoop Step intStep If findProcess = True Then sngEndX = sngStartLoop picSquare.Line (sngStartX, sngStartY)-(sngEndX, sngEndY), RGB(Rnd * 256, Rnd * 256, Rnd * 256) DoEvents Else Exit For End If Next sngStartLoop End If Return YLeg: If findProcess = True Then For sngStartLoop = sngStartLoop To sngEndLoop Step intStep If findProcess = True Then sngEndY = sngStartLoop picSquare.Line (sngStartX, sngStartY)-(sngEndX, sngEndY), RGB(Rnd * 256, Rnd * 256, Rnd * 256) DoEvents Else Exit For End If Next sngStartLoop End If Return End Sub Sub DrawCircles () Static intCount As Integer Dim intRepeat As Integer Dim intLoop As Integer Dim intStep As Integer Dim sngRadius As Single Dim sngCurrentX As Single Dim sngCurrentY As Single Dim lngColour As Long Dim lngStoreColour As Long intStep = 10 ' Position center of circles in form center 'sngRadius = ((fintHeight + fintWidth) / 2) sngRadius = fintWidth / 1.75 sngCurrentX = picSquare.ScaleWidth / 2 sngCurrentY = picSquare.ScaleHeight / 2 picSquare.Cls lngStoreColour = picSquare.ForeColor If intCount > 6 Then intCount = 0 lngColour = QBColor(intCount) PrintMessage "DataCraft Development", lngColour For intLoop = 1 To sngRadius Step intStep If findProcess = True Then picSquare.Circle (sngCurrentX, sngCurrentY), intLoop, RGB(Rnd * 255, Rnd * 255, Rnd * 255) PrintMessage "DataCraft Development", lngColour DoEvents Else Exit For End If Next intLoop For intLoop = sngRadius To 1 Step -intStep If findProcess = True Then picSquare.Circle (sngCurrentX, sngCurrentY), intLoop, RGB(Rnd * 255, Rnd * 255, Rnd * 255) PrintMessage "DataCraft Development", lngColour DoEvents Else Exit For End If Next intLoop intCount = intCount + 1 picSquare.ForeColor = lngStoreColour End Sub Sub DrawDownBars () Dim sngStartX As Single Dim sngStartY As Single Dim sngEndX As Single Dim sngEndY As Single picSquare.Cls PrintMessage APP_TITLE, RGB(0, 0, 255) sngStartX = 0 sngEndX = fintWidth For sngStartY = 0 To fintHeight Step 2 If findProcess = True Then sngEndY = sngStartY picSquare.Line (sngStartX, sngStartY)-(sngEndX, sngEndY), RGB(Rnd * 256, Rnd * 256, Rnd * 256) PrintMessage APP_TITLE, RGB(0, 0, 255) DoEvents Else Exit For End If Next sngStartY End Sub Sub DrawLRLines () Dim sngStartX As Single Dim sngStartY As Single Dim sngEndX As Single Dim sngEndY As Single picSquare.Cls PrintMessage APP_TITLE, RGB(0, 0, 255) sngEndX = 0 sngEndY = fintHeight sngStartY = 0 For sngStartX = 0 To fintWidth Step 4 If findProcess = True Then picSquare.Line (sngStartX, sngStartY)-(sngEndX, sngEndY), RGB(Rnd * 256, Rnd * 256, Rnd * 256) DoEvents Else Exit For End If Next sngStartX sngStartX = fintWidth For sngStartY = 0 To fintHeight Step 4 If findProcess = True Then picSquare.Line (sngStartX, sngStartY)-(sngEndX, sngEndY), RGB(Rnd * 256, Rnd * 256, Rnd * 256) DoEvents Else Exit For End If Next sngStartY End Sub Sub DrawRLLines () Dim sngStartX As Single Dim sngStartY As Single Dim sngEndX As Single Dim sngEndY As Single picSquare.Cls PrintMessage APP_TITLE, RGB(0, 0, 255) sngEndX = fintWidth sngEndY = fintHeight sngStartX = 0 For sngStartY = fintHeight To 0 Step -4 If findProcess = True Then picSquare.Line (sngStartX, sngStartY)-(sngEndX, sngEndY), RGB(Rnd * 256, Rnd * 256, Rnd * 256) DoEvents Else Exit For End If Next sngStartY sngStartY = 0 For sngStartX = 0 To fintWidth Step 4 If findProcess = True Then picSquare.Line (sngStartX, sngStartY)-(sngEndX, sngEndY), RGB(Rnd * 256, Rnd * 256, Rnd * 256) DoEvents Else Exit For End If Next sngStartX End Sub Sub DrawSquares () ' Declare local variables Dim intLoop As Integer Dim intStep As Integer Dim intMin As Integer Dim intMax As Integer Dim varUpper As Variant Dim varLower As Variant Dim varTemp As Variant Dim lngPosX As Long Dim lngPosY As Long intStep = 2 intMin = 10 intMax = 2000 DrawWidth = 1 ' Position center of Rectangle in Object center lngPosX = (picSquare.ScaleWidth / 2) lngPosY = (picSquare.ScaleHeight / 2) 'Start a loop to radiate outwards For intLoop = intMin To intMax Step intStep If findProcess = True Then varTemp = intLoop / intMax varUpper = 1 - varTemp: varLower = 1 + varTemp picSquare.Line (lngPosX * varUpper, lngPosY * varUpper)-(lngPosX * varLower, lngPosY * varLower), RGB(Rnd * 255, Rnd * 255, Rnd * 255), B DoEvents Else Exit For End If Next intLoop 'DoEvents 'Start a loop to radiate inwards For intLoop = intMax To intMin Step -intStep If findProcess = True Then varTemp = intLoop / intMax varUpper = 1 - varTemp: varLower = 1 + varTemp picSquare.Line (lngPosX * varUpper, lngPosY * varUpper)-(lngPosX * varLower, lngPosY * varLower), RGB(Rnd * 255, Rnd * 255, Rnd * 255), B DoEvents Else Exit For End If Next intLoop DoEvents 'Release resources to windows End Sub Sub DrawUpBars () Dim sngStartX As Single Dim sngStartY As Single Dim sngEndX As Single Dim sngEndY As Single picSquare.Cls PrintMessage APP_TITLE, RGB(0, 0, 255) sngStartX = 0 sngEndX = fintWidth For sngStartY = fintHeight To 0 Step -2 If findProcess = True Then sngEndY = sngStartY picSquare.Line (sngStartX, sngStartY)-(sngEndX, sngEndY), RGB(Rnd * 256, Rnd * 256, Rnd * 256) PrintMessage APP_TITLE, RGB(0, 0, 255) DoEvents Else Exit For End If Next sngStartY End Sub Sub Form_Load () ' Center the AboutBox on the screen Me.Move ((Screen.Width - Me.Width) / 2), ((Screen.Height - Me.Height) / 2) Dim WinFlags As Long Dim Mode As String Dim Processor As String Dim strTitle As String strTitle = "About " & App.Title frmAbout.Caption = strTitle ' Dialog Boxes should only have Move and Close items ' in their System menus', so remove the others. Remove_Items_From_Sysmenu frmAbout ' Get current Windows configuration WinFlags = GetWinFlags() ' Display configuration values in Lbl_Info.Caption and Lbl_InfoValues.Caption ' (NOTE: CRLF variable causes a line break in a labels caption) If WinFlags And WF_ENHANCED Then Mode = "386 Enhanced Mode" Else Mode = "Standard Mode" Lbl_Info.Caption = Mode + Chr$(13) + Chr$(10) + "Free Memory:" + Chr$(13) + Chr$(10) + "Math Co-processor:" If WinFlags And WF_80x87 Then Processor = "Present" Else Processor = "None" Lbl_InfoValues.Caption = Chr$(13) + Chr$(10) + Format$(GetFreeSpace(0) \ 1024) + " KB" + Chr$(13) + Chr$(10) + Processor fintWidth = picSquare.ScaleWidth fintHeight = picSquare.ScaleHeight findProcess = True End Sub Sub Form_Paint () Screen.MousePointer = 0 End Sub Sub PrintMessage (TheMsg As String, TheColour As Long) picSquare.ForeColor = TheColour fintPrintX = (fintWidth - picSquare.TextWidth(TheMsg)) / 2 fintPrintY = (fintHeight - picSquare.TextHeight(TheMsg)) / 2 picSquare.CurrentX = fintPrintX picSquare.CurrentY = fintPrintY picSquare.Print TheMsg End Sub Sub Remove_Items_From_Sysmenu (A_Form As Form) Dim intMenuHandle As Integer Dim intResult As Integer ' Modal dialog boxes usually do not have a System menu or if ' they do, they consist of only MOVE and CLOSE options. This ' routine is called when a Modal dialog box is about to be ' displayed, to remove all but the MOVE and CLOSE options ' from the forms system menu. ' Obtain the handle to the forms System menu intMenuHandle = GetSystemMenu(A_Form.hWnd, 0) ' Remove all but the MOVE and CLOSE options. The menu items ' must be removed starting with the last menu item to prevent ' the menu items from taking on new position values as other ' menu items are being removed. intResult = RemoveMenu(intMenuHandle, 8, MF_BYPOSITION) 'Switch to intResult = RemoveMenu(intMenuHandle, 7, MF_BYPOSITION) 'Separator intResult = RemoveMenu(intMenuHandle, 5, MF_BYPOSITION) 'Separator intResult = RemoveMenu(intMenuHandle, 4, MF_BYPOSITION) 'Maximize intResult = RemoveMenu(intMenuHandle, 3, MF_BYPOSITION) 'Minimize intResult = RemoveMenu(intMenuHandle, 2, MF_BYPOSITION) 'Size intResult = RemoveMenu(intMenuHandle, 0, MF_BYPOSITION) 'Restore End Sub Sub tmrControl_Timer () While findProcess = True DrawCircles DrawSquares DrawLRLines DrawCircles DrawSquares DrawDownBars DrawCircles DrawSquares DrawRLLines DrawCircles DrawSquares DrawUpBars DrawAllLines Wend Unload Me End Sub